#lang scheme/gui

(require (lib "1.ss" "srfi")
         "utils.scm"
         "fst.scm")

(provide graph-canvas%)

(define graph-canvas%
  (class
   canvas%

   (init-field (fst (new fst% (parent this))))
   (define R 25)
   (define cur-state #f)
   (define clicked #f)
   (define previous #f)
;;   ;;Create the popup-menus
;;     (define state-popup-menu (new popup-menu%))
;;     (define fst-popup-menu (new popup-menu%))
;;     (define fst-popup-menu-clear '())

;;    ;;callbacks for the popup-menu-items
;;    (define/public (fst-popup-menu-clear-callback item event) '())
;;    (define/public (fst-popup-menu-simplify-callback item event) '())
;;    (define/public (fst-popup-menu-minimize-callback item event) '())
;;    (define/public (fst-popup-menu-calculate-deficiency-callback item event) '())
;;    (define/public (state-popup-menu-set-start-state-callback item event) '())
;;    (define/public (state-popup-menu-remove-callback item event) '())
;;    (define/public (state-popup-menu-rename-callback item event) '())

;;    ;;Create the popup-menu-items
;;    (for-each (lambda (x y) (create-menu-item x y))
;;              '(clear simplify minimize calculate-deficiency
;;                      set-start-state remove rename)
;;              (append (make-list 4 'fst-popup-menu)
;;                      (make-list 3 'state-popup-menu)))


   (define/public (get-fst) fst)


   (define/public (set-fst new-fst)
     (set! fst new-fst)
     (send this refresh))


   (define/public (reset)
     (set! fst (new fst% (parent this)))
     (set! cur-state #f)
     (set! clicked #f)
     (set! previous #f)
     (send this refresh))


   (define/override (on-char ch)
     (let* ((c (send ch get-key-code))
            (o (send fst consume-input c)))
       (cond [(eq? c #\space)
              (send fst next-step)]
             [o
              (send (send (send this get-parent) get-parent)
                    set-status-text
                    o)]))
     (send this refresh))


   (define/override (on-event e)
     (let ((x (send e get-x))
           (y (send e get-y)))
       (case (send e get-event-type)
         [(left-down)
          (set! clicked
                (find (lambda (s)
                        (> R (sqrt (+ (sqr (- x (send s get-x)))
                                      (sqr (- y (send s get-y)))))))
                      (send fst get-states)))]
         [(motion)
          (when (and (send e dragging?) clicked)
                (send clicked move x y)
                (send this refresh))]
         [(left-up)
          (when (eq? (send previous get-event-type) 'left-down)
                (if clicked
                    (if cur-state
                        (begin
                          (send fst add-transition cur-state clicked)
                          (send cur-state unhighlight)
                          (set! cur-state #f))
                        (begin
                          (set! cur-state clicked)
                          (send clicked highlight)))
                    (if cur-state
                        (begin
                          (send cur-state unhighlight)
                          (set! cur-state #f))
                        (send fst add-state x y)))
                (send this refresh))])
       (set! previous e)))


   ;;clean this up!
   (define/override (on-paint)
     (let* ((dc (send this get-dc))
            (point-size (send (send dc get-font) get-point-size)))
       (for
        ([s (send fst get-states)])
        (let ((x (send s get-x))
              (y (send s get-y)))
          (send* dc
                 [set-pen (if (equal? s (send fst get-cur-state))
                              "Blue" (send s get-color))
                          2 'solid]
                 [draw-ellipse (- x R) (- y R) (* 2 R) (* 2 R)]
                 [draw-text (send s get-name) (- x (/ point-size 2))
                            (- y point-size)])))
       (send dc set-pen "Black" 2 'solid)
       (for
        ([t (send fst get-transitions)])
        (let* ((SPUR_LEN 10)
               (PHI (/ pi 6))
               (x1 (get-field x (get-field head t)))
               (y1 (get-field y (get-field head t)))
               (x2 (get-field x (get-field tail t)))
               (y2 (get-field y (get-field tail t)))
               (dx (- x2 x1))
               (dy (- y2 y1))
               (L (sqrt (+ (sqr dx) (sqr dy))))
               (m (if (= 0 dx) (* dy +inf.0) (/ dy dx)))
               (text (string-append (get-field input t)
                                    "/"
                                    (get-field output t)))
               (flip (lambda (x y) (- (* 2 x) y))))
          (if (and (= x1 x2) (= y1 y2)) ;;self loops are special
              (let* ((cm (for/fold
                          ([l '(1 1 0)])
                          ([ti (send fst get-transitions)])
                          (let ((s (get-field head t)))
                            (map + l
                                 (cond [(equal? (get-field head ti) s)
                                        (let ((tail (get-field tail ti)))
                                          (list (get-field x tail)
                                                (get-field y tail) 1))]
                                       [(equal? (get-field tail ti) s)
                                        (let ((head (get-field head ti)))
                                          (list (get-field x head)
                                                (get-field y head) 1))]
                                       [#t '(0 0 0)])))))
                     (cm (for/list ([x (take cm 2)]) (/ x (third cm))))
                     (dx (- (car cm) x1))
                     (dy (- (cadr cm) y1))
                     (L (sqrt (+ (sqr dx)  (sqr dy))))
                     (m (if (= 0 dx) (* dy +inf.0) (/ dy dx)))
                     (x3 ((if (< dx 0) + -) x1 (* R (cos (+ (atan m) PHI)))))
                     (y3 ((if (< dx 0) + -) y1 (* R (sin (+ (atan m) PHI)))))
                     (x4 (- x1 (/ (* (* 2 R) dx) L)))
                     (y4 (- y1 (/ (* (* 2 R) dy) L)))
                     (xt (- x1 (/ (* (+ 15 (* 2 R)) dx) L)))
                     (yt (- y1 (/ (* (+ 15 (* 2 R)) dy) L)))
                     (x5 ((if (< dx 0) + -) x1 (* R (cos (- (atan m) PHI)))))
                     (y5 ((if (< dx 0) + -) y1 (* R (sin (- (atan m) PHI))))))
                (send* dc
                       [draw-spline x3 y3 x4 y4 x5 y5]
                       [draw-text text xt yt]))
              (if (get-field bArc t)
                  (let* ((r (+ (/ (sqr L) (* 8 R)) (/ R 2)))
                         (h (- r R))
                         (temp (if (= 0 dx)
                                   0
                                   (sqrt (/ (sqr h) (+ (sqr m) 1)))))
                         (xr ((if (> x1 x2) - +) (/ (+ x1 x2) 2)
                              (if (= 0 dx)
                                  ((if (< y1 y2) + -) h)
                                  (* m temp))))
                         (yr ((if (> x1 x2) + -) (/ (+ y1 y2) 2) temp))
                         (x (- xr r))
                         (y (- yr r))
                         (width (* 2 r))
                         (little-angle (* 2 (asin (/ (/ R 2) r))))
                         (big-angle (- (if (< xr x1) 0 pi)
                                       (if (= 0 (- x1 xr))
                                           ((if (> 0 dy) + -) (/ pi 2))
                                           (atan (/ (- y1 yr) (- x1 xr))))))
                         (start (+ little-angle big-angle))
                         (end (+ (flip (asin (/ (/ L 2) r))
                                       little-angle)
                                 big-angle))
                         (x3 (+ xr (* r (cos end))))
                         (y3 (- yr (* r (sin end))))
                         (xt (+ xr (* r (cos (+ start (/ (- end start) 2))))))
                         (yt (- yr (* r (sin (+ start (/ (- end start) 2))))))
                         (angle (if (= 0 (- y3 yr)) (/ pi 2)
                                    (atan (/ (- xr x3) (- y3 yr)))))
                         (x5 (- x3 (* SPUR_LEN (cos (+ angle PHI)))))
                         (y5 (- y3 (* SPUR_LEN (sin (+ angle PHI)))))
                         (x6 (- x3 (* SPUR_LEN (cos (- angle PHI)))))
                         (y6 (- y3 (* SPUR_LEN (sin (- angle PHI))))))
                    (send* dc
                           [draw-arc x y width width start end]
                           [draw-text text xt yt])
                    (if (>= y3 yr)
                        (send* dc
                               [draw-line x3 y3 x5 y5]
                               [draw-line x3 y3 x6 y6])
                        (send* dc
                               [draw-line x3 y3 (flip x3 x5) (flip y3 y5)]
                               [draw-line x3 y3 (flip x3 x6) (flip y3 y6)])))
                  (let* ((x3 (- x2 (/ (* dx R) L)))
                         (y3 (- y2 (/ (* dy R) L)))
                         (x4 (+ x1 (/ (* dx R) L)))
                         (y4 (+ y1 (/ (* dy R) L)))
                         (xt (/ (+ x3 x4) 2))
                         (yt (/ (+ y3 y4) 2))
                         (angle (atan m))
                         (x5 (+ x3 (* SPUR_LEN (cos (+ angle PHI)))))
                         (y5 (+ y3 (* SPUR_LEN (sin (+ angle PHI)))))
                         (x6 (+ x3 (* SPUR_LEN (cos (- angle PHI)))))
                         (y6 (+ y3 (* SPUR_LEN (sin (- angle PHI))))))
                    (send* dc
                           [draw-line x3 y3 x4 y4]
                           [draw-text text xt yt])
                    (if (< x3 x4)
                        (send* dc
                               [draw-line x3 y3 x5 y5]
                               [draw-line x3 y3 x6 y6])
                        (send* dc
                               [draw-line x3 y3 (flip x3 x5) (flip y3 y5)]
                               [draw-line x3 y3 (flip x3 x6) (flip y3 y6)])))))))))

   (super-new (style '(border)))
   (send* (send this get-dc)
          [set-pen "Black" 2 'solid]
          [set-brush "White" 'transparent])))
